;;; -*- Mode:LISP; Package:NETWORK; Readtable:CL; Base:10 -*-
;;;
;;; Stuff for parsing HOSTS2, network addresses.  NIC later
;;;

;;; Copyright LISP Machine, Inc. 1986
;;;   See filename "Copyright.Text" for
;;; licensing and release information.


(defun generate-from-hosts2-table (&optional input-file)
  (let ((default-input-file "SYS: CHAOS; HOSTS TEXT >")
        (si:*force-package* "CHAOS")
        (*read-base* 8) (*print-base* 8))
    (cond ((and (not input-file)                ;if not specified
                (not (probe-file default-input-file)))  ;and reasonable file doesn't exist
           (format *query-io* "~&Default host table input file not found.")
           (setq input-file (global:prompt-and-read `(:pathname :defaults ,default-input-file)
                                             "Please specify file to use instead: ")))
          (t
           (if (not input-file) (setq input-file default-input-file))))
    (generate-from-hosts2-table-1 input-file "SYS: SITE; HSTTBL LISP >")))

;;; System system transformation
(defun generate-from-hosts2-table-1 (input-file output-file)
  (let ((*package* (find-package "CHAOS"))
        (*read-base* 8) (*print-base* 8) (*print-radix* t)
        (*readtable* si:standard-readtable))
    (with-open-file (output-stream output-file :direction :output :characters t)
      (format output-stream "~
;;; -*- Mode: LISP;~@[ Package: ~A;~] Base: 8; Readtable:T -*-
;;; *** THIS FILE WAS AUTOMATICALLY GENERATED BY A PROGRAM, DO NOT EDIT IT ***
;;; Host table made from ~A~%"
              si:*force-package* (send (fs:parse-pathname input-file) :truename))
      (si::write-responsibility-comment output-stream)
      (generate-from-hosts2-table-2 input-file output-stream)
      (when (global:get-site-option :non-chaos-host-table-file)
        (generate-from-hosts2-table-2 (global:get-site-option :non-chaos-host-table-file)
                               output-stream)))))

(defun read-hosts2-table (input-file)
  (let ((*package* (find-package "CHAOS"))
        (*read-base* 8) (*print-base* 8) (*print-radix* t)
        (*readtable* si:standard-readtable))
    (generate-from-hosts2-table-2 input-file nil)))

(defun generate-from-hosts2-table-2 (input-file output-stream)
  (with-open-file (input-stream input-file :direction :input :characters t)
    (do ((line) (eof)
         (i) (j)
         (ni) (nj)
         (hostl) (delim)
         (result))
        (nil)
      (multiple-value-setq (line eof)
        (send input-stream :line-in nil))
      (and eof (zerop (string-length line)) (return result))
      (multiple-value-setq (i j)
        (parse-hosts2-table-token line 0))
      (cond ((and i (string-equal line "HOST" :start1 i :end1 j))
             ;; Host name
             (multiple-value-setq (ni nj)
               (parse-hosts2-table-token line (1+ j)))
             (multiple-value-setq (i j delim)
               (parse-hosts2-table-token line (1+ nj)))
             (setq hostl (ncons (substring line ni nj)))
             (if (char= delim #\[)
                 (do ((l nil)
                      (i1) (j1))
                     ((char= delim #\])
                      (incf j)
                      (nreverse l))
                   (multiple-value-setq (i1 j1 delim)
                     (parse-hosts2-table-token line (1+ j)))
                   (if (char= delim #\Sp)
                       (multiple-value-setq (i j delim)
                         (parse-hosts2-table-token line (1+ j1)))
                       (setq i i1 j j1 j1 i1))
                   (add-hosts2-table-address line i1 j1 i j hostl))
                 (let ((i1 i) (j1 j))
                   (if (char= delim #\Sp)
                       (multiple-value-setq (i j)
                         (parse-hosts2-table-token line (1+ j)))
                       (setq i i1 j j1 j1 i1))
                   (add-hosts2-table-address line i1 j1 i j hostl)))
;            (COND ((OR (GET HOSTL :CHAOS)      ;If there were any chaosnet addresses
;                       ;; Include some popular ARPA sites for speed in SUPDUP/TELNET, etc.
;                       (SYS:MEMBER-EQUAL (CAR HOSTL) INCLUDED-NON-CHAOS-HOSTS))
             (dotimes (k 2)
               (multiple-value-setq (i j delim)
                 (parse-hosts2-table-token line (1+ j))))
             (when i
               (setf (get hostl :system-type) (intern (substring line i j) "")))
             (multiple-value-setq (i j delim)
               (parse-hosts2-table-token line (1+ j)))
             (when i
               (setf (get hostl :machine-type) (intern (substring line i j) "")))
             (multiple-value-setq (i j delim)
               (parse-hosts2-table-token line (1+ j)))
             (or i (setq delim -1))
             (let* ((first-name (car hostl))
                    (namel (ncons first-name)))
               (and (char= delim #\[)
                    (do () ((char= delim #\])
                            (setq namel (stable-sort namel
                                                     #'(lambda (x y)
                                                         ;; EQ is OK here...
                                                         (and (not (eq x first-name))
                                                              (< (string-length x)
                                                                 (string-length y)))))))
                      (multiple-value-setq (i j delim)
                        (parse-hosts2-table-token line (1+ j)))
                      (unless (equal i j) ;kmc-dle's suggestion for avoiding null hostnames
                        (push (substring line i j) namel))))
               (setf (get hostl :host-names) namel))
             (if output-stream
                 (let ((*package* (or (find-package si:*force-package*) *package*)))
                      (format output-stream "(~S ~S~{~%  '~S '~S~})~2%"
                              'si::define-host (car hostl) (cdr hostl)))
               (push hostl result)))))))

(defun parse-hosts2-table-token (string &optional (start 0) end)
  (or end (setq end (length string)))
  (do ((idx start (1+ idx))
       (sidx) (ch))
      ((>= idx end)
       (values sidx idx -1))
    (setq ch (char string idx))
    (or sidx
        (member ch '(#\Sp #\Tab) :test #'eq)
        (setq sidx idx))
    (and sidx
         (member ch '(#\, #\Sp #\Tab #\[ #\]) :test #'eq)
         (return (values sidx idx ch)))))

(defun add-hosts2-table-address (line net-start net-end address-start address-end hostl
                                 &aux symbol parser)
  (setq symbol (if (= net-start net-end) :arpa
                   (intern (substring line net-start net-end) "")))
  (when (setq parser (get symbol 'address-parser))
    (setf (get hostl symbol)            ;Keep addresses in original order
          (nconc (get hostl symbol)
                 (ncons (funcall parser symbol line address-start address-end))))))

(defun parse-address (address network-type &optional (start 0) (end (string-length address)))
  "Given a string, return the parsed address for NETWORK-TYPE, a keyword"
  (let ((parser (get network-type 'address-parser)))
    (if parser
        (funcall parser network-type address start end)
      (error "Unknown network address type ~S" network-type))))

;;; Initially supported network types.  This should be sufficient
(defun (:property :chaos address-parser) (ignore line start end)
  (parse-integer line :start start :end end :radix 8.))

(defun (:property :ru address-parser) (ignore line start end)
  (parse-integer line :start start :end end :radix 8.))

(defun parse-arpa-address (ignore line start end)
  (let ((slash (string-search-char #\/ line start end)))
    (dpb (parse-integer line :start start :end slash)
         (byte 8. 9.)
         (parse-integer line :start (1+ slash) :end end))))

(setf (get :arpa 'address-parser) 'parse-arpa-address)
(setf (get :rcc 'address-parser) 'parse-arpa-address)

(defun (:property :dial address-parser) (ignore line start end)
  (substring line start end))                   ;A phone number is just characters.

(defun parse-2part-octal-address (character line start end)
  (let ((sep (string-search-char character line start end)))
    (dpb (parse-integer line :start start :end sep :radix 8.)
         (byte 8 8)
         (parse-integer line :start (1+ sep) :end end :radix 8.))))

(defun (:property :lcs address-parser) (ignore line start end)
  (parse-2part-octal-address #\/ line start end))

(defun (:property :su address-parser) (ignore line start end)
  (parse-2part-octal-address #\# line start end))

(defun parse-internet-address-component (string from to)
  (let ((number (parse-integer string :start from :end to :radix 10. :junk-allowed nil)))
    (cond ((null number)
           (error "Non-number field (~A) in \"~A\"" (substring string from to) string))
          ((or (> number 255.) (minusp number))
           (error "Number (~D) out of range in Internet address" number))
          (t number))))

(defun (:property :internet address-parser) (ignore line start end)
  (do ((local-to 0) (idx 3) (address 0))
      ((= idx -1) address)
    (setq local-to (string-search-char #\. line start end))
    (if (null local-to)
        (if (zerop idx) (setq local-to end)
          (error "Not enough fields for an Internet address")))
    (setq address
          (dpb (parse-internet-address-component line start local-to)
               (byte 8. (* 8. idx))
               address))
    (decf idx)
    (setq start (+ local-to 1))))

;;; Generation of standard format host table files from the current state of the machine.
;;; Someday, there will be other keyword args for namespaces, filtering, date last changed,
;;; domain suffices, etc.
(defun dump-host-table-file (file format &rest keys)
  (let ((char (get format 'comment-character #\;))
        (handler (get format 'output-handler))
        (preamble-handler (get format 'preamble-handler))
        (postamble-handler (get format 'postamble-handler)))
    (if handler
        (with-open-file (out file :direction :output)
          (si:write-responsibility-comment out char)
          (when preamble-handler
            (funcall preamble-handler out))
          (apply #'dump-host-table-to-stream out handler keys)
          (when postamble-handler
            (funcall postamble-handler out)))
      (error "~S is not a known host table file format." format))))

(defun dump-host-table-to-stream (stream handler &rest keys)
  (si:do-all-hosts (h)
    (apply handler h stream keys)))

;;; Writes out all but the primary name, with name as file computer last.
(defun write-other-host-names (host stream separator  element-format)
  (let* ((names (send host :host-names))
         (first-name (send host :name)))
    (loop for i from (- (length names) 1) downto 0
          do (let ((name (elt names i)))
               (unless (string= name first-name)
                 (format stream element-format name)
                 (unless (zerop i) (write-string separator stream)))))))

(defun unparse-address (address network-type)
  (funcall (or (get network-type 'si::address-unparser) 'si::default-address-unparser) address))

(defconstant default-hosts2-network-numbers '((:chaos . 7)))

(global:define-site-variable *hosts2-network-numbers* :hosts2-network-numbers
  "An alist of network types and numbers for HOSTS2 format tables.")

(defun write-hosts2-preamble (stream)
  (dolist (e (or *hosts2-network-numbers* default-hosts2-network-numbers))
    (format stream "NET ~A, ~O~%" (car e) (cdr e)))
  (terpri stream))

(setf (get :hosts2 'preamble-handler) 'write-hosts2-preamble)

(defun (:property :hosts2 output-handler) (host stream &rest ignore)
  (let ((as (send host :chaos-addresses)))
    (when as
      (format stream "HOST ~A,~C" (send host :name) #\Tab)
      (cond ((null (cdr as)) ; only one address
             (format stream "CHAOS ~O," (first as)))
            (t
             (write-char #\[ stream)
             (format:print-list stream "CHAOS ~O" as ",")
             (write-string "]," stream)))
      ;; Don't sweat the USER/SERVER detritus for now...
      (format stream "USER,~A,~A,[" (send host :system-type) (send host :machine-type))
      (write-other-host-names host stream "," "~A")
      (write-line "]" stream))))

;;; We really can't do the NIC format yet because we don't save information about protocols.

;;; Then there is the extended NIC format which includes Chaosnet.

;;; Stupid Unix Internet table format (but it's stupid enough for us !).
;;; Seems to allow only one Internet address per host.
(setf (get :unix-internet 'comment-character) #\#)

(defun (:property :unix-internet output-handler) (host stream &rest ignore)
  (when (send host :network-typep :internet)
    (format stream "~A ~C~(~A~) "
            (send host :unparsed-network-address :internet) #\Tab (send host :name))
    (write-other-host-names host stream " " "~(~A~)")
    (terpri stream)))
